home *** CD-ROM | disk | FTP | other *** search
Text File | 1991-10-28 | 55.3 KB | 1,853 lines
Newsgroups: comp.sources.misc From: daveg@synaptics.com (David Gillespie) Subject: v24i051: gnucalc - GNU Emacs Calculator, v2.00, Part03/56 Message-ID: <1991Oct29.040930.6764@sparky.imd.sterling.com> X-Md4-Signature: fdd5e62069db2ae9b6bb07ec6b4e64d9 Date: Tue, 29 Oct 1991 04:09:30 GMT Approved: kent@sparky.imd.sterling.com Submitted-by: daveg@synaptics.com (David Gillespie) Posting-number: Volume 24, Issue 51 Archive-name: gnucalc/part03 Environment: Emacs Supersedes: gmcalc: Volume 13, Issue 27-45 ---- Cut Here and unpack ---- #!/bin/sh # this is Part.03 (part 3 of a multipart archive) # do not concatenate these parts, unpack them in order with /bin/sh # file calc.el continued # if test ! -r _shar_seq_.tmp; then echo 'Please unpack part 1 first!' exit 1 fi (read Scheck if test "$Scheck" != 3; then echo Please unpack part "$Scheck" next! exit 1 else exit 0 fi ) < _shar_seq_.tmp || exit 1 if test ! -f _shar_wnt_.tmp; then echo 'x - still skipping calc.el' else echo 'x - continuing file calc.el' sed 's/^X//' << 'SHAR_EOF' >> 'calc.el' && X (cdr math-eval-rules-cache) X nil math-eval-rules-cache)))) X (if func X (apply (cdr func) args) X (and (or (consp (car a)) X (fboundp (car a)) X (and (not calc-extensions-loaded) X (calc-extensions) X (fboundp (car a)))) X (apply (car a) args))))) X (wrong-number-of-arguments X (calc-record-why "*Wrong number of arguments" X (cons (car a) args)) X nil) X (wrong-type-argument X (or calc-next-why (calc-record-why "Wrong type of argument" X (cons (car a) args))) X nil) X (args-out-of-range X (calc-record-why "*Argument out of range" (cons (car a) args)) X nil) X (inexact-result X (calc-record-why "No exact representation for result" X (cons (car a) args)) X nil) X (math-overflow X (calc-record-why "*Floating-point overflow occurred" X (cons (car a) args)) X nil) X (math-underflow X (calc-record-why "*Floating-point underflow occurred" X (cons (car a) args)) X nil) X (void-variable X (if (eq (nth 1 err) 'var-EvalRules) X (progn X (setq var-EvalRules nil) X (math-normalize (cons (car a) args))) X (calc-record-why "*Variable is void" (nth 1 err))))) X (if (consp (car a)) X (math-dimension-error) X (cons (car a) args))))))) ) X X X ;;; True if A is a floating-point real or complex number. [P x] [Public] (defun math-floatp (a) X (cond ((eq (car-safe a) 'float) t) X ((memq (car-safe a) '(cplx polar mod sdev intv)) X (or (math-floatp (nth 1 a)) X (math-floatp (nth 2 a)) X (and (eq (car a) 'intv) (math-floatp (nth 3 a))))) X ((eq (car-safe a) 'date) X (math-floatp (nth 1 a)))) ) X X X ;;; Verify that A is a complete object and return A. [x x] [Public] (defun math-check-complete (a) X (cond ((integerp a) a) X ((eq (car-safe a) 'incomplete) X (calc-incomplete-error a)) X ((consp a) a) X (t (error "Invalid data object encountered"))) ) X X X ;;; Coerce integer A to be a bignum. [B S] (defun math-bignum (a) X (if (>= a 0) X (cons 'bigpos (math-bignum-big a)) X (cons 'bigneg (math-bignum-big (- a)))) ) X (defun math-bignum-big (a) ; [L s] X (if (= a 0) X nil X (cons (% a 1000) (math-bignum-big (/ a 1000)))) ) X X ;;; Build a normalized floating-point number. [F I S] (defun math-make-float (mant exp) X (if (eq mant 0) X '(float 0 0) X (let* ((ldiff (- calc-internal-prec (math-numdigs mant)))) X (if (< ldiff 0) X (setq mant (math-scale-rounding mant ldiff) X exp (- exp ldiff)))) X (if (consp mant) X (let ((digs (cdr mant))) X (if (= (% (car digs) 10) 0) X (progn X (while (= (car digs) 0) X (setq digs (cdr digs) X exp (+ exp 3))) X (while (= (% (car digs) 10) 0) X (setq digs (math-div10-bignum digs) X exp (1+ exp))) X (setq mant (math-normalize (cons (car mant) digs)))))) X (while (= (% mant 10) 0) X (setq mant (/ mant 10) X exp (1+ exp)))) X (if (and (<= exp -4000000) X (<= (+ exp (math-numdigs mant) -1) -4000000)) X (signal 'math-underflow nil) X (if (and (>= exp 3000000) X (>= (+ exp (math-numdigs mant) -1) 4000000)) X (signal 'math-overflow nil) X (list 'float mant exp)))) ) X (defun math-div10-bignum (a) ; [l l] X (if (cdr a) X (cons (+ (/ (car a) 10) (* (% (nth 1 a) 10) 100)) X (math-div10-bignum (cdr a))) X (list (/ (car a) 10))) ) X ;;; Coerce A to be a float. [F N; V V] [Public] (defun math-float (a) X (cond ((Math-integerp a) (math-make-float a 0)) X ((eq (car a) 'frac) (math-div (math-float (nth 1 a)) (nth 2 a))) X ((eq (car a) 'float) a) X ((memq (car a) '(cplx polar vec hms date sdev mod)) X (cons (car a) (mapcar 'math-float (cdr a)))) X (t (math-float-fancy a))) ) X X (defun math-neg (a) X (cond ((not (consp a)) (- a)) X ((eq (car a) 'bigpos) (cons 'bigneg (cdr a))) X ((eq (car a) 'bigneg) (cons 'bigpos (cdr a))) X ((memq (car a) '(frac float)) X (list (car a) (Math-integer-neg (nth 1 a)) (nth 2 a))) X ((memq (car a) '(cplx vec hms date calcFunc-idn)) X (cons (car a) (mapcar 'math-neg (cdr a)))) X (t (math-neg-fancy a))) ) X X ;;; Compute the number of decimal digits in integer A. [S I] (defun math-numdigs (a) X (if (consp a) X (if (cdr a) X (let* ((len (1- (length a))) X (top (nth len a))) X (+ (* len 3) (cond ((>= top 100) 0) ((>= top 10) -1) (t -2)))) X 0) X (cond ((>= a 100) (+ (math-numdigs (/ a 1000)) 3)) X ((>= a 10) 2) X ((>= a 1) 1) X ((= a 0) 0) X ((> a -10) 1) X ((> a -100) 2) X (t (math-numdigs (- a))))) ) X ;;; Multiply (with truncation toward 0) the integer A by 10^N. [I i S] (defun math-scale-int (a n) X (cond ((= n 0) a) X ((> n 0) (math-scale-left a n)) X (t (math-normalize (math-scale-right a (- n))))) ) X (defun math-scale-left (a n) ; [I I S] X (if (= n 0) X a X (if (consp a) X (cons (car a) (math-scale-left-bignum (cdr a) n)) X (if (>= n 3) X (if (or (>= a 1000) (<= a -1000)) X (math-scale-left (math-bignum a) n) X (math-scale-left (* a 1000) (- n 3))) X (if (= n 2) X (if (or (>= a 10000) (<= a -10000)) X (math-scale-left (math-bignum a) 2) X (* a 100)) X (if (or (>= a 100000) (<= a -100000)) X (math-scale-left (math-bignum a) 1) X (* a 10)))))) ) X (defun math-scale-left-bignum (a n) X (if (>= n 3) X (while (>= (setq a (cons 0 a) X n (- n 3)) 3))) X (if (> n 0) X (math-mul-bignum-digit a (if (= n 2) 100 10) 0) X a) ) X (defun math-scale-right (a n) ; [i i S] X (if (= n 0) X a X (if (consp a) X (cons (car a) (math-scale-right-bignum (cdr a) n)) X (if (<= a 0) X (if (= a 0) X 0 X (- (math-scale-right (- a) n))) X (if (>= n 3) X (while (and (> (setq a (/ a 1000)) 0) X (>= (setq n (- n 3)) 3)))) X (if (= n 2) X (/ a 100) X (if (= n 1) X (/ a 10) X a))))) ) X (defun math-scale-right-bignum (a n) ; [L L S; l l S] X (if (>= n 3) X (setq a (nthcdr (/ n 3) a) X n (% n 3))) X (if (> n 0) X (cdr (math-mul-bignum-digit a (if (= n 2) 10 100) 0)) X a) ) X ;;; Multiply (with rounding) the integer A by 10^N. [I i S] (defun math-scale-rounding (a n) X (cond ((>= n 0) X (math-scale-left a n)) X ((consp a) X (math-normalize X (cons (car a) X (let ((val (if (< n -3) X (math-scale-right-bignum (cdr a) (- -3 n)) X (if (= n -2) X (math-mul-bignum-digit (cdr a) 10 0) X (if (= n -1) X (math-mul-bignum-digit (cdr a) 100 0) X (cdr a)))))) ; n = -3 X (if (and val (>= (car val) 500)) X (if (cdr val) X (if (eq (car (cdr val)) 999) X (math-add-bignum (cdr val) '(1)) X (cons (1+ (car (cdr val))) (cdr (cdr val)))) X '(1)) X (cdr val)))))) X (t X (if (< a 0) X (- (math-scale-rounding (- a) n)) X (if (= n -1) X (/ (+ a 5) 10) X (/ (+ (math-scale-right a (- -1 n)) 5) 10))))) ) X X ;;; Compute the sum of A and B. [O O O] [Public] (defun math-add (a b) X (or X (and (not (or (consp a) (consp b))) X (progn X (setq a (+ a b)) X (if (or (<= a -1000000) (>= a 1000000)) X (math-bignum a) X a))) X (and (Math-zerop a) (not (eq (car-safe a) 'mod)) X (if (and (math-floatp a) (Math-ratp b)) (math-float b) b)) X (and (Math-zerop b) (not (eq (car-safe b) 'mod)) X (if (and (math-floatp b) (Math-ratp a)) (math-float a) a)) X (and (Math-objvecp a) (Math-objvecp b) X (or X (and (Math-integerp a) (Math-integerp b) X (progn X (or (consp a) (setq a (math-bignum a))) X (or (consp b) (setq b (math-bignum b))) X (if (eq (car a) 'bigneg) X (if (eq (car b) 'bigneg) X (cons 'bigneg (math-add-bignum (cdr a) (cdr b))) X (math-normalize X (let ((diff (math-sub-bignum (cdr b) (cdr a)))) X (if (eq diff 'neg) X (cons 'bigneg (math-sub-bignum (cdr a) (cdr b))) X (cons 'bigpos diff))))) X (if (eq (car b) 'bigneg) X (math-normalize X (let ((diff (math-sub-bignum (cdr a) (cdr b)))) X (if (eq diff 'neg) X (cons 'bigneg (math-sub-bignum (cdr b) (cdr a))) X (cons 'bigpos diff)))) X (cons 'bigpos (math-add-bignum (cdr a) (cdr b))))))) X (and (Math-ratp a) (Math-ratp b) X (calc-extensions) X (calc-add-fractions a b)) X (and (Math-realp a) (Math-realp b) X (progn X (or (and (consp a) (eq (car a) 'float)) X (setq a (math-float a))) X (or (and (consp b) (eq (car b) 'float)) X (setq b (math-float b))) X (math-add-float a b))) X (and (calc-extensions) X (math-add-objects-fancy a b)))) X (and (calc-extensions) X (math-add-symb-fancy a b))) ) X (defun math-add-bignum (a b) ; [L L L; l l l] X (if a X (if b X (let* ((a (copy-sequence a)) (aa a) (carry nil) sum) X (while (and aa b) X (if carry X (if (< (setq sum (+ (car aa) (car b))) 999) X (progn X (setcar aa (1+ sum)) X (setq carry nil)) X (setcar aa (+ sum -999))) X (if (< (setq sum (+ (car aa) (car b))) 1000) X (setcar aa sum) X (setcar aa (+ sum -1000)) X (setq carry t))) X (setq aa (cdr aa) X b (cdr b))) X (if carry X (if b X (nconc a (math-add-bignum b '(1))) X (while (eq (car aa) 999) X (setcar aa 0) X (setq aa (cdr aa))) X (if aa X (progn X (setcar aa (1+ (car aa))) X a) X (nconc a '(1)))) X (if b X (nconc a b) X a))) X a) X b) ) X (defun math-sub-bignum (a b) ; [l l l] X (if b X (if a X (let* ((a (copy-sequence a)) (aa a) (borrow nil) sum) X (while (and aa b) X (if borrow X (if (>= (setq diff (- (car aa) (car b))) 1) X (progn X (setcar aa (1- diff)) X (setq borrow nil)) X (setcar aa (+ diff 999))) X (if (>= (setq diff (- (car aa) (car b))) 0) X (setcar aa diff) X (setcar aa (+ diff 1000)) X (setq borrow t))) X (setq aa (cdr aa) X b (cdr b))) X (if borrow X (progn X (while (eq (car aa) 0) X (setcar aa 999) X (setq aa (cdr aa))) X (if aa X (progn X (setcar aa (1- (car aa))) X a) X 'neg)) X (while (eq (car b) 0) X (setq b (cdr b))) X (if b X 'neg X a))) X (while (eq (car b) 0) X (setq b (cdr b))) X (and b X 'neg)) X a) ) X (defun math-add-float (a b) ; [F F F] X (let ((ediff (- (nth 2 a) (nth 2 b)))) X (if (>= ediff 0) X (if (>= ediff (+ calc-internal-prec calc-internal-prec)) X a X (math-make-float (math-add (nth 1 b) X (if (eq ediff 0) X (nth 1 a) X (math-scale-left (nth 1 a) ediff))) X (nth 2 b))) X (if (>= (setq ediff (- ediff)) X (+ calc-internal-prec calc-internal-prec)) X b X (math-make-float (math-add (nth 1 a) X (math-scale-left (nth 1 b) ediff)) X (nth 2 a))))) ) X ;;; Compute the difference of A and B. [O O O] [Public] (defun math-sub (a b) X (if (or (consp a) (consp b)) X (math-add a (math-neg b)) X (setq a (- a b)) X (if (or (<= a -1000000) (>= a 1000000)) X (math-bignum a) X a)) ) X (defun math-sub-float (a b) ; [F F F] X (let ((ediff (- (nth 2 a) (nth 2 b)))) X (if (>= ediff 0) X (if (>= ediff (+ calc-internal-prec calc-internal-prec)) X a X (math-make-float (math-add (Math-integer-neg (nth 1 b)) X (if (eq ediff 0) X (nth 1 a) X (math-scale-left (nth 1 a) ediff))) X (nth 2 b))) X (if (>= (setq ediff (- ediff)) X (+ calc-internal-prec calc-internal-prec)) X b X (math-make-float (math-add (nth 1 a) X (Math-integer-neg X (math-scale-left (nth 1 b) ediff))) X (nth 2 a))))) ) X X ;;; Compute the product of A and B. [O O O] [Public] (defun math-mul (a b) X (or X (and (not (consp a)) (not (consp b)) X (< a 1000) (> a -1000) (< b 1000) (> b -1000) X (* a b)) X (and (Math-zerop a) (not (eq (car-safe b) 'mod)) X (if (Math-scalarp b) X (if (and (math-floatp b) (Math-ratp a)) (math-float a) a) X (calc-extensions) X (math-mul-zero a b))) X (and (Math-zerop b) (not (eq (car-safe a) 'mod)) X (if (Math-scalarp a) X (if (and (math-floatp a) (Math-ratp b)) (math-float b) b) X (calc-extensions) X (math-mul-zero b a))) X (and (Math-objvecp a) (Math-objvecp b) X (or X (and (Math-integerp a) (Math-integerp b) X (progn X (or (consp a) (setq a (math-bignum a))) X (or (consp b) (setq b (math-bignum b))) X (math-normalize X (cons (if (eq (car a) (car b)) 'bigpos 'bigneg) X (if (cdr (cdr a)) X (if (cdr (cdr b)) X (math-mul-bignum (cdr a) (cdr b)) X (math-mul-bignum-digit (cdr a) (nth 1 b) 0)) X (math-mul-bignum-digit (cdr b) (nth 1 a) 0)))))) X (and (Math-ratp a) (Math-ratp b) X (calc-extensions) X (calc-mul-fractions a b)) X (and (Math-realp a) (Math-realp b) X (progn X (or (and (consp a) (eq (car a) 'float)) X (setq a (math-float a))) X (or (and (consp b) (eq (car b) 'float)) X (setq b (math-float b))) X (math-make-float (math-mul (nth 1 a) (nth 1 b)) X (+ (nth 2 a) (nth 2 b))))) X (and (calc-extensions) X (math-mul-objects-fancy a b)))) X (and (calc-extensions) X (math-mul-symb-fancy a b))) ) X (defun math-infinitep (a &optional undir) X (while (and (consp a) (memq (car a) '(* / neg))) X (if (or (not (eq (car a) '*)) (math-infinitep (nth 1 a))) X (setq a (nth 1 a)) X (setq a (nth 2 a)))) X (and (consp a) X (eq (car a) 'var) X (memq (nth 2 a) '(var-inf var-uinf var-nan)) X (if (and undir (eq (nth 2 a) 'var-inf)) X '(var uinf var-uinf) X a)) ) X ;;; Multiply digit lists A and B. [L L L; l l l] (defun math-mul-bignum (a b) X (and a b X (let* ((sum (if (<= (car b) 1) X (if (= (car b) 0) X (list 0) X (copy-sequence a)) X (math-mul-bignum-digit a (car b) 0))) X (sump sum) c d aa ss prod) X (while (setq b (cdr b)) X (setq ss (setq sump (or (cdr sump) (setcdr sump (list 0)))) X d (car b) X c 0 X aa a) X (while (progn X (setcar ss (% (setq prod (+ (+ (car ss) (* (car aa) d)) X c)) 1000)) X (setq aa (cdr aa))) X (setq c (/ prod 1000) X ss (or (cdr ss) (setcdr ss (list 0))))) X (if (>= prod 1000) X (if (cdr ss) X (setcar (cdr ss) (+ (/ prod 1000) (car (cdr ss)))) X (setcdr ss (list (/ prod 1000)))))) X sum)) ) X ;;; Multiply digit list A by digit D. [L L D D; l l D D] (defun math-mul-bignum-digit (a d c) X (if a X (if (<= d 1) X (and (= d 1) a) X (let* ((a (copy-sequence a)) (aa a) prod) X (while (progn X (setcar aa (% (setq prod (+ (* (car aa) d) c)) 1000)) X (cdr aa)) X (setq aa (cdr aa) X c (/ prod 1000))) X (if (>= prod 1000) X (setcdr aa (list (/ prod 1000)))) X a)) X (and (> c 0) X (list c))) ) X X ;;; Compute the integer (quotient . remainder) of A and B, which may be ;;; small or big integers. Type and consistency of truncation is undefined ;;; if A or B is negative. B must be nonzero. [I.I I I] [Public] (defun math-idivmod (a b) X (if (eq b 0) X (math-reject-arg a "*Division by zero")) X (if (or (consp a) (consp b)) X (if (and (natnump b) (< b 1000)) X (let ((res (math-div-bignum-digit (cdr a) b))) X (cons X (math-normalize (cons (car a) (car res))) X (cdr res))) X (or (consp a) (setq a (math-bignum a))) X (or (consp b) (setq b (math-bignum b))) X (let ((res (math-div-bignum (cdr a) (cdr b)))) X (cons X (math-normalize (cons (if (eq (car a) (car b)) 'bigpos 'bigneg) X (car res))) X (math-normalize (cons (car a) (cdr res)))))) X (cons (/ a b) (% a b))) ) X (defun math-quotient (a b) ; [I I I] [Public] X (if (and (not (consp a)) (not (consp b))) X (if (= b 0) X (math-reject-arg a "*Division by zero") X (/ a b)) X (if (and (natnump b) (< b 1000)) X (if (= b 0) X (math-reject-arg a "*Division by zero") X (math-normalize (cons (car a) X (car (math-div-bignum-digit (cdr a) b))))) X (or (consp a) (setq a (math-bignum a))) X (or (consp b) (setq b (math-bignum b))) X (let* ((alen (1- (length a))) X (blen (1- (length b))) X (d (/ 1000 (1+ (nth (1- blen) (cdr b))))) X (res (math-div-bignum-big (math-mul-bignum-digit (cdr a) d 0) X (math-mul-bignum-digit (cdr b) d 0) X alen blen))) X (math-normalize (cons (if (eq (car a) (car b)) 'bigpos 'bigneg) X (car res)))))) ) X X ;;; Divide a bignum digit list by another. [l.l l L] ;;; The following division algorithm is borrowed from Knuth vol. II, sec. 4.3.1 (defun math-div-bignum (a b) X (if (cdr b) X (let* ((alen (length a)) X (blen (length b)) X (d (/ 1000 (1+ (nth (1- blen) b)))) X (res (math-div-bignum-big (math-mul-bignum-digit a d 0) X (math-mul-bignum-digit b d 0) X alen blen))) X (if (= d 1) X res X (cons (car res) X (car (math-div-bignum-digit (cdr res) d))))) X (let ((res (math-div-bignum-digit a (car b)))) X (cons (car res) (list (cdr res))))) ) X ;;; Divide a bignum digit list by a digit. [l.D l D] (defun math-div-bignum-digit (a b) X (if a X (let* ((res (math-div-bignum-digit (cdr a) b)) X (num (+ (* (cdr res) 1000) (car a)))) X (cons X (cons (/ num b) (car res)) X (% num b))) X '(nil . 0)) ) X (defun math-div-bignum-big (a b alen blen) ; [l.l l L] X (if (< alen blen) X (cons nil a) X (let* ((res (math-div-bignum-big (cdr a) b (1- alen) blen)) X (num (cons (car a) (cdr res))) X (res2 (math-div-bignum-part num b blen))) X (cons X (cons (car res2) (car res)) X (cdr res2)))) ) X (defun math-div-bignum-part (a b blen) ; a < b*1000 [D.l l L] X (let* ((num (+ (* (or (nth blen a) 0) 1000) (or (nth (1- blen) a) 0))) X (den (nth (1- blen) b)) X (guess (min (/ num den) 999))) X (math-div-bignum-try a b (math-mul-bignum-digit b guess 0) guess)) ) X (defun math-div-bignum-try (a b c guess) ; [D.l l l D] X (let ((rem (math-sub-bignum a c))) X (if (eq rem 'neg) X (math-div-bignum-try a b (math-sub-bignum c b) (1- guess)) X (cons guess rem))) ) X X ;;; Compute the quotient of A and B. [O O N] [Public] (defun math-div (a b) X (or X (and (Math-zerop b) X (calc-extensions) X (math-div-by-zero a b)) X (and (Math-zerop a) (not (eq (car-safe b) 'mod)) X (if (Math-scalarp b) X (if (and (math-floatp b) (Math-ratp a)) (math-float a) a) X (calc-extensions) X (math-div-zero a b))) X (and (Math-objvecp a) (Math-objvecp b) X (or X (and (Math-integerp a) (Math-integerp b) X (let ((q (math-idivmod a b))) X (if (eq (cdr q) 0) X (car q) X (if calc-prefer-frac X (progn X (calc-extensions) X (math-make-frac a b)) X (math-div-float (math-make-float a 0) X (math-make-float b 0)))))) X (and (Math-ratp a) (Math-ratp b) X (calc-extensions) X (calc-div-fractions a b)) X (and (Math-realp a) (Math-realp b) X (progn X (or (and (consp a) (eq (car a) 'float)) X (setq a (math-float a))) X (or (and (consp b) (eq (car b) 'float)) X (setq b (math-float b))) X (math-div-float a b))) X (and (calc-extensions) X (math-div-objects-fancy a b)))) X (and (calc-extensions) X (math-div-symb-fancy a b))) ) X (defun math-div-float (a b) ; [F F F] X (let ((ldiff (max (- (1+ calc-internal-prec) X (- (math-numdigs (nth 1 a)) (math-numdigs (nth 1 b)))) X 0))) X (math-make-float (math-quotient (math-scale-int (nth 1 a) ldiff) (nth 1 b)) X (- (- (nth 2 a) (nth 2 b)) ldiff))) ) X X X X X ;;; Format the number A as a string. [X N; X Z] [Public] (defun math-format-stack-value (entry) X (setq calc-selection-cache-entry calc-selection-cache-default-entry) X (let* ((a (car entry)) X (math-comp-selected (nth 2 entry)) X (c (cond ((null a) "<nil>") X ((eq calc-display-raw t) (format "%s" a)) X ((stringp a) a) X ((eq a 'top-of-stack) ".") X (calc-prepared-composition X calc-prepared-composition) X ((and (Math-scalarp a) X (memq calc-language '(nil flat unform)) X (null math-comp-selected)) X (math-format-number a)) X (t (calc-extensions) X (math-compose-expr a 0)))) X (off (math-stack-value-offset c)) X s w) X (and math-comp-selected (setq calc-any-selections t)) X (setq w (cdr off) X off (car off)) X (if (> off 0) X (setq c (math-comp-concat (make-string off ? ) c))) X (or (equal calc-left-label "") X (setq c (math-comp-concat (if (eq a 'top-of-stack) X (make-string (length calc-left-label) ? ) X calc-left-label) X c))) X (if calc-line-numbering X (setq c (math-comp-concat (if (eq calc-language 'big) X (if math-comp-selected X '(tag t "1: ") "1: ") X " ") X c))) X (or (equal calc-right-label "") X (eq a 'top-of-stack) X (progn X (calc-extensions) X (setq c (list 'horiz c X (make-string (max (- w (math-comp-width c) X (length calc-right-label)) 0) ? ) X '(break -1) X calc-right-label)))) X (setq s (if (stringp c) X (if calc-display-raw X (prin1-to-string c) X c) X (math-composition-to-string c w))) X (if calc-language-output-filter X (setq s (funcall calc-language-output-filter s))) X (if (eq calc-language 'big) X (setq s (concat s "\n")) X (if calc-line-numbering X (progn X (aset s 0 ?1) X (aset s 1 ?:)))) X (setcar (cdr entry) (calc-count-lines s)) X s) ) X (defun math-stack-value-offset (c) X (let* ((num (if calc-line-numbering 4 0)) X (wid (calc-window-width)) X off) X (if calc-display-just X (progn X (calc-extensions) X (math-stack-value-offset-fancy)) X (setq off (or calc-display-origin 0)) X (if (integerp calc-line-breaking) X (setq wid calc-line-breaking))) X (cons (max (- off (length calc-left-label)) 0) X (+ wid num))) ) X (defun calc-count-lines (s) X (let ((pos 0) X (num 1)) X (while (setq newpos (string-match "\n" s pos)) X (setq pos (1+ newpos) X num (1+ num))) X num) ) X (defun math-format-value (a &optional w) X (if (and (Math-scalarp a) X (memq calc-language '(nil flat unform))) X (math-format-number a) X (calc-extensions) X (let ((calc-line-breaking nil)) X (math-composition-to-string (math-compose-expr a 0) w))) ) X (defun calc-window-width () X (if calc-embedded-info X (let ((win (get-buffer-window (aref calc-embedded-info 0)))) X (1- (if win (window-width win) (screen-width)))) X (- (window-width (get-buffer-window (current-buffer))) X (if calc-line-numbering 5 1))) ) X (defun math-comp-concat (c1 c2) X (if (and (stringp c1) (stringp c2)) X (concat c1 c2) X (list 'horiz c1 c2)) ) X X X ;;; Format an expression as a one-line string suitable for re-reading. X (defun math-format-flat-expr (a prec) X (cond X ((or (not (or (consp a) (integerp a))) X (eq calc-display-raw t)) X (let ((print-escape-newlines t)) X (concat "'" (prin1-to-string a)))) X ((Math-scalarp a) X (let ((calc-group-digits nil) X (calc-point-char ".") X (calc-frac-format (if (> (length (car calc-frac-format)) 1) X '("::" nil) '(":" nil))) X (calc-complex-format nil) X (calc-hms-format "%s@ %s' %s\"") X (calc-language nil)) X (math-format-number a))) X (t X (calc-extensions) X (math-format-flat-expr-fancy a prec))) ) X X X ;;; Format a number as a string. (defun math-format-number (a &optional prec) ; [X N] [Public] X (cond X ((eq calc-display-raw t) (format "%s" a)) X ((and (nth 1 calc-frac-format) (Math-integerp a)) X (calc-extensions) X (math-format-number (math-adjust-fraction a))) X ((integerp a) X (if (not (or calc-group-digits calc-leading-zeros)) X (if (= calc-number-radix 10) X (int-to-string a) X (if (< a 0) X (concat "-" (math-format-number (- a))) X (calc-extensions) X (if math-radix-explicit-format X (if calc-radix-formatter X (funcall calc-radix-formatter X calc-number-radix X (if (= calc-number-radix 2) X (math-format-binary a) X (math-format-radix a))) X (format "%d#%s" calc-number-radix X (if (= calc-number-radix 2) X (math-format-binary a) X (math-format-radix a)))) X (math-format-radix a)))) X (math-format-number (math-bignum a)))) X ((stringp a) a) X ((eq (car a) 'bigpos) (math-format-bignum (cdr a))) X ((eq (car a) 'bigneg) (concat "-" (math-format-bignum (cdr a)))) X ((and (eq (car a) 'float) (= calc-number-radix 10)) X (if (Math-integer-negp (nth 1 a)) X (concat "-" (math-format-number (math-neg a))) X (let ((mant (nth 1 a)) X (exp (nth 2 a)) X (fmt (car calc-float-format)) X (figs (nth 1 calc-float-format)) X (point calc-point-char) X str) X (if (and (eq fmt 'fix) X (or (and (< figs 0) (setq figs (- figs))) X (> (+ exp (math-numdigs mant)) (- figs)))) X (progn X (setq mant (math-scale-rounding mant (+ exp figs)) X str (if (integerp mant) X (int-to-string mant) X (math-format-bignum-decimal (cdr mant)))) X (if (<= (length str) figs) X (setq str (concat (make-string (1+ (- figs (length str))) ?0) X str))) X (if (> figs 0) X (setq str (concat (substring str 0 (- figs)) point X (substring str (- figs)))) X (setq str (concat str point))) X (if calc-group-digits X (setq str (math-group-float str)))) X (if (< figs 0) X (setq figs (+ calc-internal-prec figs))) X (if (> figs 0) X (let ((adj (- figs (math-numdigs mant)))) X (if (< adj 0) X (setq mant (math-scale-rounding mant adj) X exp (- exp adj))))) X (setq str (if (integerp mant) X (int-to-string mant) X (math-format-bignum-decimal (cdr mant)))) X (let* ((len (length str)) X (dpos (+ exp len))) X (if (and (eq fmt 'float) X (<= dpos (+ calc-internal-prec calc-display-sci-high)) X (>= dpos (+ calc-display-sci-low 2))) X (progn X (cond X ((= dpos 0) X (setq str (concat "0" point str))) X ((and (<= exp 0) (> dpos 0)) X (setq str (concat (substring str 0 dpos) point X (substring str dpos)))) X ((> exp 0) X (setq str (concat str (make-string exp ?0) point))) X (t ; (< dpos 0) X (setq str (concat "0" point X (make-string (- dpos) ?0) str)))) X (if calc-group-digits X (setq str (math-group-float str)))) X (let* ((eadj (+ exp len)) X (scale (if (eq fmt 'eng) X (1+ (math-mod (+ eadj 300002) 3)) X 1))) X (if (> scale (length str)) X (setq str (concat str (make-string (- scale (length str)) X ?0)))) X (if (< scale (length str)) X (setq str (concat (substring str 0 scale) point X (substring str scale)))) X (if calc-group-digits X (setq str (math-group-float str))) X (setq str (format (if (memq calc-language '(math maple)) X (if (and prec (> prec 191)) X "(%s*10.^%d)" "%s*10.^%d") X "%se%d") X str (- eadj scale))))))) X str))) X (t X (calc-extensions) X (math-format-number-fancy a prec))) ) X (defun math-format-bignum (a) ; [X L] X (if (and (= calc-number-radix 10) X (not calc-leading-zeros) X (not calc-group-digits)) X (math-format-bignum-decimal a) X (calc-extensions) X (math-format-bignum-fancy a)) ) X (defun math-format-bignum-decimal (a) ; [X L] X (if a X (let ((s "")) X (while (cdr (cdr a)) X (setq s (concat (format "%06d" (+ (* (nth 1 a) 1000) (car a))) s) X a (cdr (cdr a)))) X (concat (int-to-string (+ (* (or (nth 1 a) 0) 1000) (car a))) s)) X "0") ) X X X ;;; Parse a simple number in string form. [N X] [Public] (defun math-read-number (s) X (math-normalize X (cond X X ;; Integers (most common case) X ((string-match "\\` *\\([0-9]+\\) *\\'" s) X (let ((digs (math-match-substring s 1))) X (if (and (eq calc-language 'c) X (> (length digs) 1) X (eq (aref digs 0) ?0)) X (math-read-number (concat "8#" digs)) X (if (<= (length digs) 6) X (string-to-int digs) X (cons 'bigpos (math-read-bignum digs)))))) X X ;; Clean up the string if necessary X ((string-match "\\`\\(.*\\)[ \t\n]+\\([^\001]\\)*\\'" s) X (math-read-number (concat (math-match-substring s 1) X (math-match-substring s 2)))) X X ;; Plus and minus signs X ((string-match "^[-_+]\\(.*\\)$" s) X (let ((val (math-read-number (math-match-substring s 1)))) X (and val (if (eq (aref s 0) ?+) val (math-neg val))))) X X ;; Forms that require extensions module X ((string-match "[^-+0-9eE.]" s) X (calc-extensions) X (math-read-number-fancy s)) X X ;; Decimal point X ((string-match "^\\([0-9]*\\)\\.\\([0-9]*\\)$" s) X (let ((int (math-match-substring s 1)) X (frac (math-match-substring s 2))) X (let ((ilen (length int)) X (flen (length frac))) X (let ((int (if (> ilen 0) (math-read-number int) 0)) X (frac (if (> flen 0) (math-read-number frac) 0))) X (and int frac (or (> ilen 0) (> flen 0)) X (list 'float X (math-add (math-scale-int int flen) frac) X (- flen))))))) X X ;; "e" notation X ((string-match "^\\(.*\\)[eE]\\([-+]?[0-9]+\\)$" s) X (let ((mant (math-match-substring s 1)) X (exp (math-match-substring s 2))) X (let ((mant (if (> (length mant) 0) (math-read-number mant) 1)) X (exp (if (<= (length exp) (if (memq (aref exp 0) '(?+ ?-)) 8 7)) X (string-to-int exp)))) X (and mant exp (Math-realp mant) (> exp -4000000) (< exp 4000000) X (let ((mant (math-float mant))) X (list 'float (nth 1 mant) (+ (nth 2 mant) exp))))))) X X ;; Syntax error! X (t nil))) ) X (defun math-match-substring (s n) X (if (match-beginning n) X (substring s (match-beginning n) (match-end n)) X "") ) X (defun math-read-bignum (s) ; [l X] X (if (> (length s) 3) X (cons (string-to-int (substring s -3)) X (math-read-bignum (substring s 0 -3))) X (list (string-to-int s))) ) X X (defconst math-tex-ignore-words X '( ("\\hbox") ("\\mbox") ("\\text") ("\\left") ("\\right") X ("\\,") ("\\>") ("\\:") ("\\;") ("\\!") ("\\ ") X ("\\quad") ("\\qquad") ("\\hfil") ("\\hfill") X ("\\displaystyle") ("\\textstyle") ("\\dsize") ("\\tsize") X ("\\scriptstyle") ("\\scriptscriptstyle") ("\\ssize") ("\\sssize") X ("\\rm") ("\\bf") ("\\it") ("\\sl") X ("\\roman") ("\\bold") ("\\italic") ("\\slanted") X ("\\cal") ("\\mit") ("\\Cal") ("\\Bbb") ("\\frak") ("\\goth") X ("\\evalto") X ("\\matrix" mat) ("\\bmatrix" mat) ("\\pmatrix" mat) X ("\\cr" punc ";") ("\\\\" punc ";") ("\\*" punc "*") X ("\\{" punc "[") ("\\}" punc "]") )) X (defconst math-eqn-ignore-words X '( ("roman") ("bold") ("italic") ("mark") ("lineup") ("evalto") X ("left" ("floor") ("ceil")) X ("right" ("floor") ("ceil")) X ("arc" ("sin") ("cos") ("tan") ("sinh") ("cosh") ("tanh")) X ("size" n) ("font" n) ("fwd" n) ("back" n) ("up" n) ("down" n) X ("above" punc ",") )) X (defconst math-standard-opers X '( ( "_" calcFunc-subscr 1200 1201 ) X ( "%" calcFunc-percent 1100 -1 ) X ( "u+" ident -1 1000 ) X ( "u-" neg -1 1000 197 ) X ( "u!" calcFunc-lnot -1 1000 ) X ( "mod" mod 400 400 185 ) X ( "+/-" sdev 300 300 185 ) X ( "!!" calcFunc-dfact 210 -1 ) X ( "!" calcFunc-fact 210 -1 ) X ( "^" ^ 201 200 ) X ( "**" ^ 201 200 ) X ( "*" * 196 195 ) X ( "2x" * 196 195 ) X ( "/" / 190 191 ) X ( "%" % 190 191 ) X ( "\\" calcFunc-idiv 190 191 ) X ( "+" + 180 181 ) X ( "-" - 180 181 ) X ( "|" | 170 171 ) X ( "<" calcFunc-lt 160 161 ) X ( ">" calcFunc-gt 160 161 ) X ( "<=" calcFunc-leq 160 161 ) X ( ">=" calcFunc-geq 160 161 ) X ( "=" calcFunc-eq 160 161 ) X ( "==" calcFunc-eq 160 161 ) X ( "!=" calcFunc-neq 160 161 ) X ( "&&" calcFunc-land 110 111 ) X ( "||" calcFunc-lor 100 101 ) X ( "?" (math-read-if) 91 90 ) X ( "!!!" calcFunc-pnot -1 85 ) X ( "&&&" calcFunc-pand 80 81 ) X ( "|||" calcFunc-por 75 76 ) X ( ":=" calcFunc-assign 51 50 ) X ( "::" calcFunc-condition 45 46 ) X ( "=>" calcFunc-evalto 40 41 ) X ( "=>" calcFunc-evalto 40 -1 ) )) (setq math-expr-opers math-standard-opers) X X ;;;###autoload (defun calc-grab-region (top bot arg) X "Parse the region as a vector of numbers and push it on the Calculator stack." X (interactive "r\nP") X (calc-extensions) X (calc-do-grab-region top bot arg) ) X ;;;###autoload (defun calc-grab-rectangle (top bot arg) X "Parse a rectangle as a matrix of numbers and push it on the Calculator stack." X (interactive "r\nP") X (calc-extensions) X (calc-do-grab-rectangle top bot arg) ) X (defun calc-grab-sum-down (top bot arg) X "Parse a rectangle as a matrix of numbers and sum its columns." X (interactive "r\nP") X (calc-extensions) X (calc-do-grab-rectangle top bot arg) X (if (eq major-mode 'calc-mode) X (calc-slow-wrapper X (calc-enter-result 1 "red+" (list 'calcFunc-reduced X '(var add var-add) X (calc-top-n 1))))) ) X (defun calc-grab-sum-across (top bot arg) X "Parse a rectangle as a matrix of numbers and sum its rows." X (interactive "r\nP") X (calc-extensions) X (calc-do-grab-rectangle top bot arg) X (if (eq major-mode 'calc-mode) X (calc-slow-wrapper X (calc-enter-result 1 "red+" (list 'calcFunc-reducea X '(var add var-add) X (calc-top-n 1))))) ) X X ;;;###autoload (defun calc-embedded (arg &optional end obeg oend) X "Start Calc Embedded mode on the formula surrounding point." X (interactive "P") X (calc-extensions) X (calc-do-embedded arg end obeg oend) ) X ;;;###autoload (defun calc-embedded-activate (&optional arg cbuf) X "Scan the current editing buffer for all embedded := and => formulas. Also looks for the equivalent TeX words, \\gets and \\evalto." X (interactive "P") X (calc-do-embedded-activate arg cbuf) ) X X (defun calc-user-invocation () X (interactive) X (or (stringp calc-invocation-macro) X (error "Use `Z I' inside Calc to define a `M-# Z' keyboard macro")) X (execute-kbd-macro calc-invocation-macro nil) ) X X X X ;;; User-programmability. X ;;;###autoload (defmacro defmath (func args &rest body) ; [Public] X (calc-extensions) X (math-do-defmath func args body) ) X X X (if calc-always-load-extensions X (progn X (calc-extensions) X (calc-load-everything)) ) X X (run-hooks 'calc-load-hook) X X SHAR_EOF echo 'File calc.el is complete' && chmod 0644 calc.el || echo 'restore of calc.el failed' Wc_c="`wc -c < 'calc.el'`" test 112529 -eq "$Wc_c" || echo 'calc.el: original size 112529, current size' "$Wc_c" rm -f _shar_wnt_.tmp fi # ============= calc-aent.el ============== if test -f 'calc-aent.el' -a X"$1" != X"-c"; then echo 'x - skipping calc-aent.el (File already exists)' rm -f _shar_wnt_.tmp else > _shar_wnt_.tmp echo 'x - extracting calc-aent.el (Text)' sed 's/^X//' << 'SHAR_EOF' > 'calc-aent.el' && ;; Calculator for GNU Emacs, part I [calc-aent.el] ;; Copyright (C) 1990, 1991 Free Software Foundation, Inc. ;; Written by Dave Gillespie, daveg@csvax.cs.caltech.edu. X ;; This file is part of GNU Emacs. X ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY. No author or distributor ;; accepts responsibility to anyone for the consequences of using it ;; or for whether it serves any particular purpose or works at all, ;; unless he says so in writing. Refer to the GNU Emacs General Public ;; License for full details. X ;; Everyone is granted permission to copy, modify and redistribute ;; GNU Emacs, but only under the conditions described in the ;; GNU Emacs General Public License. A copy of this license is ;; supposed to have been given to you along with GNU Emacs so you ;; can know your rights and responsibilities. It should be in a ;; file named COPYING. Among other things, the copyright notice ;; and this notice must be preserved on all copies. X X X ;; This file is autoloaded from calc.el. (require 'calc) X (require 'calc-macs) X (defun calc-Need-calc-aent () nil) X X (defun calc-do-quick-calc () X (calc-check-defines) X (if (eq major-mode 'calc-mode) X (calc-algebraic-entry t) X (let (buf shortbuf) X (save-excursion X (calc-create-buffer) X (let* ((calc-command-flags nil) X (calc-dollar-values calc-quick-prev-results) X (calc-dollar-used 0) X (enable-recursive-minibuffers t) X (calc-language (if (memq calc-language '(nil big)) X 'flat calc-language)) X (entry (calc-do-alg-entry "" "Quick calc: " t)) X (alg-exp (mapcar (function X (lambda (x) X (if (and (not calc-extensions-loaded) X calc-previous-alg-entry X (string-match X "\\`[-0-9._+*/^() ]+\\'" X calc-previous-alg-entry)) X (calc-normalize x) X (calc-extensions) X (math-evaluate-expr x)))) X entry))) X (if (and (= (length alg-exp) 1) X (eq (car-safe (car alg-exp)) 'calcFunc-assign) X (= (length (car alg-exp)) 3) X (eq (car-safe (nth 1 (car alg-exp))) 'var)) X (progn X (calc-extensions) X (set (nth 2 (nth 1 (car alg-exp))) (nth 2 (car alg-exp))) X (calc-refresh-evaltos (nth 2 (nth 1 (car alg-exp)))) X (setq alg-exp (list (nth 2 (car alg-exp)))))) X (setq calc-quick-prev-results alg-exp X buf (mapconcat (function (lambda (x) X (math-format-value x 1000))) X alg-exp X " ") X shortbuf buf) X (if (and (= (length alg-exp) 1) X (memq (car-safe (car alg-exp)) '(nil bigpos bigneg)) X (< (length buf) 20) X (= calc-number-radix 10)) X (setq buf (concat buf " (" X (let ((calc-number-radix 16)) X (math-format-value (car alg-exp) 1000)) X ", " X (let ((calc-number-radix 8)) X (math-format-value (car alg-exp) 1000)) X (if (and (integerp (car alg-exp)) X (> (car alg-exp) 0) X (< (car alg-exp) 127)) X (format ", \"%c\"" (car alg-exp)) X "") X ")"))) X (if (and (< (length buf) (screen-width)) (= (length entry) 1) X calc-extensions-loaded) X (let ((long (concat (math-format-value (car entry) 1000) X " => " buf))) X (if (<= (length long) (- (screen-width) 8)) X (setq buf long)))) X (calc-handle-whys) X (message "Result: %s" buf))) X (if (eq last-command-char 10) X (insert shortbuf) X (setq kill-ring (cons shortbuf kill-ring)) X (if (> (length kill-ring) kill-ring-max) X (setcdr (nthcdr (1- kill-ring-max) kill-ring) nil)) X (setq kill-ring-yank-pointer kill-ring)))) ) X (defun calc-do-calc-eval (str separator args) X (calc-check-defines) X (catch 'calc-error X (save-excursion X (calc-create-buffer) X (cond X ((and (consp str) (not (symbolp (car str)))) X (let ((calc-language nil) X (math-expr-opers math-standard-opers) X (calc-internal-prec 12) X (calc-word-size 32) X (calc-symbolic-mode nil) X (calc-matrix-mode nil) X (calc-angle-mode 'deg) X (calc-number-radix 10) X (calc-leading-zeros nil) X (calc-group-digits nil) X (calc-point-char ".") X (calc-frac-format '(":" nil)) X (calc-prefer-frac nil) X (calc-hms-format "%s@ %s' %s\"") X (calc-date-format '((H ":" mm C SS pp " ") X Www " " Mmm " " D ", " YYYY)) X (calc-float-format '(float 0)) X (calc-full-float-format '(float 0)) X (calc-complex-format nil) X (calc-matrix-just nil) X (calc-full-vectors t) X (calc-break-vectors nil) X (calc-vector-commas ",") X (calc-vector-brackets "[]") X (calc-matrix-brackets '(R O)) X (calc-complex-mode 'cplx) X (calc-infinite-mode nil) X (calc-display-strings nil) X (calc-simplify-mode nil) X (calc-display-working-message 'lots) X (strp (cdr str))) X (while strp X (set (car strp) (nth 1 strp)) X (setq strp (cdr (cdr strp)))) X (calc-do-calc-eval (car str) separator args))) X ((eq separator 'eval) X (eval str)) X ((eq separator 'macro) X (calc-extensions) X (let* ((calc-buffer (current-buffer)) X (calc-window (get-buffer-window calc-buffer)) X (save-window (selected-window))) X (if calc-window X (unwind-protect X (progn X (select-window calc-window) X (calc-execute-kbd-macro str nil (car args))) X (and (window-point save-window) X (select-window save-window))) X (save-window-excursion X (select-window (get-largest-window)) X (switch-to-buffer calc-buffer) X (calc-execute-kbd-macro str nil (car args))))) X nil) X ((eq separator 'pop) X (or (not (integerp str)) X (= str 0) X (calc-pop (min str (calc-stack-size)))) X (calc-stack-size)) X ((eq separator 'top) X (and (integerp str) X (> str 0) X (<= str (calc-stack-size)) X (math-format-value (calc-top-n str (car args)) 1000))) X ((eq separator 'rawtop) X (and (integerp str) X (> str 0) X (<= str (calc-stack-size)) X (calc-top-n str (car args)))) X (t X (let* ((calc-command-flags nil) X (calc-next-why nil) X (calc-language (if (memq calc-language '(nil big)) X 'flat calc-language)) X (calc-dollar-values (mapcar X (function X (lambda (x) X (if (stringp x) X (progn X (setq x (math-read-exprs x)) X (if (eq (car-safe x) X 'error) X (throw 'calc-error X (calc-eval-error X (cdr x))) X (car x))) X x))) X args)) X (calc-dollar-used 0) X (res (if (stringp str) X (math-read-exprs str) X (list str))) X buf) X (if (eq (car res) 'error) X (calc-eval-error (cdr res)) X (setq res (mapcar 'calc-normalize res)) X (and (memq 'clear-message calc-command-flags) X (message "")) X (cond ((eq separator 'pred) X (if (= (length res) 1) X (math-is-true (car res)) X (calc-eval-error '(0 "Single value expected")))) X ((eq separator 'raw) X (if (= (length res) 1) X (car res) X (calc-eval-error '(0 "Single value expected")))) X ((eq separator 'list) X res) X ((memq separator '(num rawnum)) X (if (= (length res) 1) X (if (math-constp (car res)) X (if (eq separator 'num) X (math-format-value (car res) 1000) X (car res)) X (calc-eval-error X (list 0 X (if calc-next-why X (calc-explain-why (car calc-next-why)) X "Number expected")))) X (calc-eval-error '(0 "Single value expected")))) X ((eq separator 'push) X (calc-push-list res) X nil) X (t (while res X (setq buf (concat buf X (and buf (or separator ", ")) X (math-format-value (car res) 1000)) X res (cdr res))) X buf)))))))) ) X (defun calc-eval-error (msg) X (if (and (boundp 'calc-eval-error) X calc-eval-error) X (if (eq calc-eval-error 'string) X (nth 1 msg) X (error "%s" (nth 1 msg))) X msg) ) X X ;;;; Reading an expression in algebraic form. X (defun calc-auto-algebraic-entry (&optional prefix) X (interactive "P") X (calc-algebraic-entry prefix t) ) X (defun calc-algebraic-entry (&optional prefix auto) X (interactive "P") X (calc-wrapper X (let ((calc-language (if prefix nil calc-language)) X (math-expr-opers (if prefix math-standard-opers math-expr-opers))) X (calc-alg-entry (and auto (char-to-string last-command-char))))) ) X (defun calc-alg-entry (&optional initial prompt) X (let* ((sel-mode nil) X (calc-dollar-values (mapcar 'calc-get-stack-element X (nthcdr calc-stack-top calc-stack))) X (calc-dollar-used 0) X (calc-plain-entry t) X (alg-exp (calc-do-alg-entry initial prompt t))) X (if (stringp alg-exp) X (progn X (calc-extensions) X (calc-alg-edit alg-exp)) X (let* ((calc-simplify-mode (if (eq last-command-char ?\C-j) X 'none X calc-simplify-mode)) X (nvals (mapcar 'calc-normalize alg-exp))) X (while alg-exp X (calc-record (if calc-extensions-loaded (car alg-exp) (car nvals)) X "alg'") X (calc-pop-push-record-list calc-dollar-used X (and (not (equal (car alg-exp) X (car nvals))) X calc-extensions-loaded X "") X (list (car nvals))) X (setq alg-exp (cdr alg-exp) X nvals (cdr nvals) X calc-dollar-used 0))) X (calc-handle-whys))) ) X (defun calc-do-alg-entry (&optional initial prompt no-normalize) X (let* ((calc-buffer (current-buffer)) X (blink-paren-hook 'calcAlg-blink-matching-open) X (alg-exp 'error)) X (if (boundp 'calc-alg-ent-map) X () X (setq calc-alg-ent-map (copy-keymap minibuffer-local-map)) X (define-key calc-alg-ent-map "'" 'calcAlg-previous) X (define-key calc-alg-ent-map "`" 'calcAlg-edit) X (define-key calc-alg-ent-map "\C-m" 'calcAlg-enter) X (define-key calc-alg-ent-map "\C-j" 'calcAlg-enter) X (setq calc-alg-ent-esc-map (copy-keymap esc-map)) X (let ((i 33)) X (while (< i 127) X (aset calc-alg-ent-esc-map i 'calcAlg-escape) X (setq i (1+ i))))) X (define-key calc-alg-ent-map "\e" nil) X (if (eq calc-algebraic-mode 'total) X (define-key calc-alg-ent-map "\e" calc-alg-ent-esc-map) X (define-key calc-alg-ent-map "\ep" 'calcAlg-plus-minus) X (define-key calc-alg-ent-map "\em" 'calcAlg-mod)) X (setq calc-aborted-prefix nil) X (let ((buf (read-from-minibuffer (or prompt "Algebraic: ") X (or initial "") X calc-alg-ent-map nil))) X (if (eq alg-exp 'error) X (if (eq (car-safe (setq alg-exp (math-read-exprs buf))) 'error) X (setq alg-exp nil))) X (setq calc-aborted-prefix "alg'") X (or no-normalize X (and alg-exp (setq alg-exp (mapcar 'calc-normalize alg-exp)))) X alg-exp)) ) X (defun calcAlg-plus-minus () X (interactive) X (if (calc-minibuffer-contains ".* \\'") X (insert "+/- ") X (insert " +/- ")) ) X (defun calcAlg-mod () X (interactive) X (if (not (calc-minibuffer-contains ".* \\'")) X (insert " ")) X (if (calc-minibuffer-contains ".* mod +\\'") X (if calc-previous-modulo X (insert (math-format-flat-expr calc-previous-modulo 0)) X (beep)) X (insert "mod ")) ) X (defun calcAlg-previous () X (interactive) X (if (calc-minibuffer-contains "\\`\\'") X (if calc-previous-alg-entry X (insert calc-previous-alg-entry) X (beep)) X (insert "'")) ) X (defun calcAlg-escape () X (interactive) X (setq unread-command-char last-command-char) X (save-excursion X (calc-select-buffer) X (use-local-map calc-mode-map)) X (calcAlg-enter) ) X (defun calcAlg-edit () X (interactive) X (if (or (not calc-plain-entry) X (calc-minibuffer-contains X "\\`\\([^\"]*\"[^\"]*\"\\)*[^\"]*\"[^\"]*\\'")) X (insert "`") X (setq alg-exp (buffer-string)) X (and (> (length alg-exp) 0) (setq calc-previous-alg-entry alg-exp)) X (exit-minibuffer)) ) (setq calc-plain-entry nil) X (defun calcAlg-enter () X (interactive) X (let* ((str (buffer-string)) X (exp (and (> (length str) 0) X (save-excursion X (set-buffer calc-buffer) X (math-read-exprs str))))) X (if (eq (car-safe exp) 'error) X (progn X (goto-char (point-min)) X (forward-char (nth 1 exp)) X (beep) X (calc-temp-minibuffer-message X (concat " [" (or (nth 2 exp) "Error") "]")) X (setq unread-command-char -1)) X (setq alg-exp (if (calc-minibuffer-contains "\\` *\\[ *\\'") X '((incomplete vec)) X exp)) X (and (> (length str) 0) (setq calc-previous-alg-entry str)) X (exit-minibuffer))) ) X (defun calcAlg-blink-matching-open () X (let ((oldpos (point)) X (blinkpos nil)) X (save-excursion X (condition-case () X (setq blinkpos (scan-sexps oldpos -1)) X (error nil))) X (if (and blinkpos X (> oldpos (1+ (point-min))) X (or (and (= (char-after (1- oldpos)) ?\)) X (= (char-after blinkpos) ?\[)) X (and (= (char-after (1- oldpos)) ?\]) X (= (char-after blinkpos) ?\())) X (save-excursion X (goto-char blinkpos) X (looking-at ".+\\(\\.\\.\\|\\\\dots\\|\\\\ldots\\)"))) X (let ((saved (aref (syntax-table) (char-after blinkpos)))) X (unwind-protect X (progn X (aset (syntax-table) (char-after blinkpos) X (+ (logand saved 255) X (lsh (char-after (1- oldpos)) 8))) X (blink-matching-open)) X (aset (syntax-table) (char-after blinkpos) saved))) X (blink-matching-open))) ) X X (defun calc-alg-digit-entry () X (calc-alg-entry X (cond ((eq last-command-char ?e) X (if (> calc-number-radix 14) (format "%d.^" calc-number-radix) "1e")) X ((eq last-command-char ?#) (format "%d#" calc-number-radix)) X ((eq last-command-char ?_) "-") X ((eq last-command-char ?@) "0@ ") X (t (char-to-string last-command-char)))) ) X (defun calcDigit-algebraic () X (interactive) X (if (calc-minibuffer-contains ".*[@oh] *[^'m ]+[^'m]*\\'") X (calcDigit-key) X (setq calc-digit-value (buffer-string)) X (exit-minibuffer)) ) X (defun calcDigit-edit () X (interactive) X (setq unread-command-char last-command-char) X (setq calc-digit-value (buffer-string)) X (exit-minibuffer) ) X X ;;; Algebraic expression parsing. [Public] X (defun math-read-exprs (exp-str) X (let ((exp-pos 0) X (exp-old-pos 0) X (exp-keep-spaces nil) X exp-token exp-data) X (if calc-language-input-filter X (setq exp-str (funcall calc-language-input-filter exp-str))) X (while (setq exp-token (string-match "\\.\\." exp-str)) X (setq exp-str (concat (substring exp-str 0 exp-token) "\\dots" X (substring exp-str (+ exp-token 2))))) X (math-read-token) X (let ((val (catch 'syntax (math-read-expr-list)))) X (if (stringp val) X (list 'error exp-old-pos val) X (if (equal exp-token 'end) X val X (list 'error exp-old-pos "Syntax error"))))) ) X (defun math-read-expr-list () X (let* ((exp-keep-spaces nil) X (val (list (math-read-expr-level 0))) X (last val)) X (while (equal exp-data ",") X (math-read-token) X (let ((rest (list (math-read-expr-level 0)))) X (setcdr last rest) X (setq last rest))) X val) ) X (defun math-read-token () X (if (>= exp-pos (length exp-str)) X (setq exp-old-pos exp-pos X exp-token 'end X exp-data "\000") X (let ((ch (aref exp-str exp-pos))) X (setq exp-old-pos exp-pos) X (cond ((memq ch '(32 10 9)) X (setq exp-pos (1+ exp-pos)) X (if exp-keep-spaces X (setq exp-token 'space X exp-data " ") X (math-read-token))) X ((or (and (>= ch ?a) (<= ch ?z)) X (and (>= ch ?A) (<= ch ?Z))) X (string-match (if (memq calc-language '(c fortran pascal maple)) X "[a-zA-Z0-9_#]*" X "[a-zA-Z0-9'#]*") X exp-str exp-pos) X (setq exp-token 'symbol X exp-pos (match-end 0) X exp-data (math-restore-dashes X (math-match-substring exp-str 0))) X (if (eq calc-language 'eqn) X (let ((code (assoc exp-data math-eqn-ignore-words))) X (cond ((null code)) X ((null (cdr code)) X (math-read-token)) X ((consp (nth 1 code)) X (math-read-token) X (if (assoc exp-data (cdr code)) X (setq exp-data (format "%s %s" X (car code) exp-data)))) X ((eq (nth 1 code) 'punc) X (setq exp-token 'punc X exp-data (nth 2 code))) X (t X (math-read-token) X (math-read-token)))))) X ((or (and (>= ch ?0) (<= ch ?9)) X (and (eq ch '?\.) X (eq (string-match "\\.[0-9]" exp-str exp-pos) exp-pos)) X (and (eq ch '?_) X (eq (string-match "_\\.?[0-9]" exp-str exp-pos) exp-pos) X (or (eq exp-pos 0) X (and (memq calc-language '(nil flat big unform X tex eqn)) X (eq (string-match "[^])}\"a-zA-Z0-9'$]_" X exp-str (1- exp-pos)) X (1- exp-pos)))))) X (or (and (eq calc-language 'c) X (string-match "0[xX][0-9a-fA-F]+" exp-str exp-pos)) X (string-match "_?\\([0-9]+.?0*@ *\\)?\\([0-9]+.?0*' *\\)?\\(0*\\([2-9]\\|1[0-4]\\)\\(#\\|\\^\\^\\)[0-9a-dA-D.]+[eE][-+_]?[0-9]+\\|0*\\([2-9]\\|[0-2][0-9]\\|3[0-6]\\)\\(#\\|\\^\\^\\)[0-9a-zA-Z:.]+\\|[0-9]+:[0-9:]+\\|[0-9.]+\\([eE][-+_]?[0-9]+\\)?\"?\\)?" exp-str exp-pos)) X (setq exp-token 'number X exp-data (math-match-substring exp-str 0) X exp-pos (match-end 0))) X ((eq ch ?\$) X (if (and (eq calc-language 'pascal) X (eq (string-match X "\\(\\$[0-9a-fA-F]+\\)\\($\\|[^0-9a-zA-Z]\\)" X exp-str exp-pos) X exp-pos)) X (setq exp-token 'number X exp-data (math-match-substring exp-str 1) X exp-pos (match-end 1)) X (if (eq (string-match "\\$\\([1-9][0-9]*\\)" exp-str exp-pos) X exp-pos) X (setq exp-data (- (string-to-int (math-match-substring X exp-str 1)))) X (string-match "\\$+" exp-str exp-pos) X (setq exp-data (- (match-end 0) (match-beginning 0)))) X (setq exp-token 'dollar X exp-pos (match-end 0)))) X ((eq ch ?\#) X (if (eq (string-match "#\\([1-9][0-9]*\\)" exp-str exp-pos) X exp-pos) X (setq exp-data (string-to-int X (math-match-substring exp-str 1)) X exp-pos (match-end 0)) X (setq exp-data 1 X exp-pos (1+ exp-pos))) X (setq exp-token 'hash)) X ((eq (string-match "~=\\|<=\\|>=\\|<>\\|/=\\|\\+/-\\|\\\\dots\\|\\\\ldots\\|\\*\\*\\|<<\\|>>\\|==\\|!=\\|&&&\\||||\\|!!!\\|&&\\|||\\|!!\\|:=\\|::\\|=>" X exp-str exp-pos) X exp-pos) X (setq exp-token 'punc X exp-data (math-match-substring exp-str 0) X exp-pos (match-end 0))) X ((and (eq ch ?\") X (string-match "\\(\"\\([^\"\\]\\|\\\\.\\)*\\)\\(\"\\|\\'\\)" exp-str exp-pos)) X (if (eq calc-language 'eqn) X (progn X (setq exp-str (copy-sequence exp-str)) X (aset exp-str (match-beginning 1) ?\{) X (if (< (match-end 1) (length exp-str)) X (aset exp-str (match-end 1) ?\})) X (math-read-token)) X (setq exp-token 'string X exp-data (math-match-substring exp-str 1) X exp-pos (match-end 0)))) X ((and (= ch ?\\) (eq calc-language 'tex)) X (or (string-match "\\\\hbox *{\\([a-zA-Z0-9]+\\)}" exp-str exp-pos) X (string-match "\\(\\\\\\([a-zA-Z]+\\|[^a-zA-Z]\\)\\)" exp-str exp-pos)) X (setq exp-token 'symbol X exp-pos (match-end 0) X exp-data (math-restore-dashes X (math-match-substring exp-str 1))) X (let ((code (assoc exp-data math-tex-ignore-words))) X (cond ((null code)) X ((null (cdr code)) X (math-read-token)) X ((eq (nth 1 code) 'punc) X (setq exp-token 'punc X exp-data (nth 2 code))) X ((and (eq (nth 1 code) 'mat) X (string-match " *{" exp-str exp-pos)) X (setq exp-pos (match-end 0) X exp-token 'punc X exp-data "[") X (let ((right (string-match "}" exp-str exp-pos))) X (and right X (setq exp-str (copy-sequence exp-str)) X (aset exp-str right ?\]))))))) X ((and (= ch ?\.) (eq calc-language 'fortran) X (eq (string-match "\\.[a-zA-Z][a-zA-Z][a-zA-Z]?\\." X exp-str exp-pos) exp-pos)) X (setq exp-token 'punc SHAR_EOF true || echo 'restore of calc-aent.el failed' fi echo 'End of part 3' echo 'File calc-aent.el is continued in part 4' echo 4 > _shar_seq_.tmp exit 0 exit 0 # Just in case... -- Kent Landfield INTERNET: kent@sparky.IMD.Sterling.COM Sterling Software, IMD UUCP: uunet!sparky!kent Phone: (402) 291-8300 FAX: (402) 291-4362 Please send comp.sources.misc-related mail to kent@uunet.uu.net. 
